Disc to the Future 2/Disc to the Future Part II Programmer's Reference (Wayzata Technology)(6013)(1992).bin/UNIX/PASCAL/PTOC/PTC_P.4

Text File | 1992-11-23 | 54KB | 2,234 lines

                    end
            until    tq = nil;
        555:
            writeln(';');
            if tp^.tt = nvarpar then
                if tp^.tbind^.tt = nconfarr then
                    begin
                    indent;
                    etypedef(tp^.tbind^.tindtyp);
                    write(tab1);
                    tq := tp^.tbind^.tcindx^.thi;
                    printid(tq^.tsym^.lid);
                    writeln(';')
                    end;
            tp := tp^.tnext
            end
    end;    (* evar *)

    (*    Emit code for a statment.                *)
    procedure estmt(tp : treeptr);

    var    tq    : treeptr;
        locid1,
        locid2    : idptr;
        stusd    : boolean;
        opc1,
        opc2    : char;

        (*    Emit typename for with-variable.        *)
        procedure ewithtype(tp : treeptr);

        var    tq    : treeptr;

        begin
            tq := typeof(tp);
            write('struct ');
            printid(tq^.tuid)
        end;

        (*    Emit code for a case-choise.        *)
        procedure echoise(tp : treeptr);

        var    tq    : treeptr;
            i    : integer;

        begin
            while tp <> nil do
                begin
                tq := tp^.tchocon;
                i := 0;
                indent;
                while tq <> nil do
                    begin
                    write('  case ');
                    conflag := true;
                    eexpr(tq);
                    conflag := false;
                    write(':');
                    i := i + 1;
                    tq := tq^.tnext;
                    if (tq = nil) or (i mod 4 = 0) then
                        begin
                        writeln;
                        if tq <> nil then
                            indent;
                        i := 0
                        end
                    end;
                increment;
                if tp^.tchostmt^.tt = nbegin then
                    estmt(tp^.tchostmt^.tbegin)
                else
                    estmt(tp^.tchostmt);
                indent;
                writeln('break ;');
                decrement;
                tp := tp^.tnext;
                if tp <> nil then
                    if tp^.tchocon = nil then
                        tp := nil
                end
        end;    (* echoise *)

        (*    Rename all accessible record-fields to include    *)
        (*    pointer name.                    *)
        procedure cenv(ip : idptr; dp : declptr);

        var    tp    : treeptr;
            sp    : symptr;
            np    : idptr;
            h    : hashtyp;

        begin
            with dp^ do
              for h := 0 to hashmax - 1 do
                begin
                sp := ddecl[h];
                while sp <> nil do
                    begin
                    if sp^.lt = lfield  then
                        begin
                        np := sp^.lid;
                        tp := sp^.lsymdecl^.tup^.tup;
                        if (tp^.tup^.tt = nvariant) and
                            (tp^.tuid <> nil) then
                            np := mkconc('.',
                                tp^.tuid, np);
                        np := mkconc('>', ip, np);
                        sp^.lid := np
                        end;
                    sp := sp^.lnext
                    end
                end
        end;    (* cenv *)

        (*    Emit identifiers for push/pop of global ptrs.    *)
        procedure eglobid(tp : treeptr);

        var    j    : toknidx;
            w    : toknbuf;

        begin
            gettokn(tp^.tsym^.lid^.istr, w);
            j := 1;
            if w[1] = '*' then
                j := 2;
            while w[j] <> chr(null) do
                begin
                write(w[j]);
                j := j + 1
                end
        end;

    begin    (* estmt *)
        while tp <> nil do
            begin
            case tp^.tt of
              nbegin:
                begin
                if tp^.tup^.tt in [nbegin, nrepeat,
                        nproc, nfunc, npgm] then
                    indent;
                writeln('{');
                increment;
                estmt(tp^.tbegin);
                decrement;
                indent;
                write('}');
                if tp^.tup^.tt <> nif then
                    writeln
                end;
              nrepeat:
                begin
                indent;
                writeln('do {');
                increment;
                estmt(tp^.treptstmt);
                decrement;
                indent;
                write('} while (!(');
                eexpr(tp^.treptxp);
                writeln('));')
                end;
              nwhile:
                begin
                indent;
                write('while (');
                increment;
                eexpr(tp^.twhixp);
                stusd := setused;
                if tp^.twhistmt^.tt = nbegin then
                    begin
                    decrement;
                    write(') ');
                    estmt(tp^.twhistmt)
                    end
                else begin
                    writeln(')');
                    estmt(tp^.twhistmt);
                    decrement
                     end;
                setused := stusd or setused
                end;
              nfor:
                begin
                indent;
                if tp^.tincr then
                    begin
                    opc1 := '+';    (* increment variable *)
                    opc2 := '<'    (* test for <= *)
                    end
                else begin
                    opc1 := '-';    (* decrement variable *)
                    opc2 := '>';    (* test for >= *)
                     end;
                if not lazyfor then
                    begin
                    locid1 := mkvariable('B');
                    locid2 := mkvariable('B');
                    writeln('{');
                    increment;
                    indent;
                    tq := idup(tp^.tforid);
                    etypedef(tq^.tbind);
                    tq := typeof(tq^.tbind);
                    write(tab1);
                    printid(locid1);
                    write(' = ');
                    eexpr(tp^.tfrom);
                    writeln(',');
                    indent;
                    write(tab1);
                    printid(locid2);
                    write(' = ');
                    eexpr(tp^.tto);
                    writeln(';');
                    writeln;
                    indent;
                    write('if (');
                    if tq^.tt = nscalar then
                        begin
                        write('(int)(');
                        printid(locid1);
                        write(')')
                        end
                    else
                        printid(locid1);
                    write(' ', opc2, '= ');
                    if tq^.tt = nscalar then
                        begin
                        write('(int)(');
                        printid(locid2);
                        write(')')
                        end
                    else
                        printid(locid2);
                    writeln(')');
                    increment;
                    indent;
                    tp^.tfrom := newid(locid1);
                    tp^.tfrom^.tup := tp
                    end;
                write('for (');
                increment;
                eexpr(tp^.tforid);
                tq := typeof(tp^.tforid);
                write(' = ');
                eexpr(tp^.tfrom);
                write('; ');
                if lazyfor then
                    begin
                    if tq^.tt = nscalar then
                        begin
                        write('(int)(');
                        eexpr(tp^.tforid);
                        write(')')
                        end
                    else
                        eexpr(tp^.tforid);
                    write(' ', opc2, '= ');
                    if tq^.tt = nscalar then
                        begin
                        write('(int)(');
                        eexpr(tp^.tto);
                        write(')')
                        end
                    else
                        eexpr(tp^.tto)
                    end;
                write('; ');
                eexpr(tp^.tforid);
                if tq^.tt = nscalar then
                    begin
                    write(' = (');
                    eexpr(tq^.tup^.tidl);
                    write(')((int)(');
                    eexpr(tp^.tforid);
                    write(')', opc1, '1)')
                    end
                else
                    write(opc1, opc1);
                if not lazyfor then
                    begin
                    if tp^.tforstmt^.tt <> nbegin then
                        begin
                        (* create compund stmt *)
                        tq := mknode(nbegin);
                        tq^.tbegin := tp^.tforstmt;
                        tq^.tbegin^.tup := tq;
                        tp^.tforstmt := tq;
                        tq^.tup := tp
                        end;
                    (* find end of loop *)
                    tq := tp^.tforstmt^.tbegin;
                    while tq^.tnext <> nil do
                        tq := tq^.tnext;
                    (* add break stmt *)
                    tq^.tnext := mknode(nbreak);
                    tq := tq^.tnext;
                    tq^.tup := tp^.tforstmt;
                    tq^.tbrkid := tp^.tforid;
                    tq^.tbrkxp := newid(locid2);
                    tq^.tbrkxp^.tup := tq
                    end;
                if tp^.tforstmt^.tt = nbegin then
                    begin
                    decrement;
                    write(') ');
                    estmt(tp^.tforstmt)
                    end
                else begin
                    writeln(')');
                    estmt(tp^.tforstmt);
                    decrement
                     end;
                if not lazyfor then
                    begin
                    decrement;
                    decrement;
                    indent;
                    writeln('}')
                    end
                end;
              nif:
                begin
                indent;
                write('if (');
                increment;
                eexpr(tp^.tifxp);
                stusd := setused;
                setused := false;
                if tp^.tthen^.tt = nbegin then
                    begin
                    decrement;
                    write(') ');
                    estmt(tp^.tthen);
                    if tp^.telse <> nil then
                        write(space)
                    else
                        writeln
                    end
                else begin
                    writeln(')');
                    estmt(tp^.tthen);
                    decrement;
                    if tp^.telse <> nil then
                        indent
                     end;
                if tp^.telse <> nil then
                    begin
                    write('else');
                    if tp^.telse^.tt = nbegin then
                        begin
                        write(space);
                        estmt(tp^.telse);
                        writeln
                        end
                    else begin
                        increment;
                        writeln;
                        estmt(tp^.telse);
                        decrement
                         end;
                    end;
                setused := stusd or setused
                end;
              ncase:
                begin
                indent;
                write('switch (');
                increment;
                eexpr(tp^.tcasxp);
                writeln(') {');
                decrement;
                echoise(tp^.tcaslst);
                indent;
                writeln('  default:');
                increment;
                if tp^.tcasother = nil then
                    begin
                    indent;
                    writeln('Caseerror(Line);')
                    end
                else
                    estmt(tp^.tcasother);
                decrement;
                indent;
                writeln('}')
                end;
              nwith:
                begin
                indent;
                writeln('{');
                increment;
                tq := tp^.twithvar;
                while tq <> nil do
                    begin
                    indent;
                    write(registr);
                    ewithtype(tq^.texpw);
                    write(' *');
                    locid1 := mkvariable('W');
                    printid(locid1);
                    write(' = ');
                    eaddr(tq^.texpw);
                    writeln(';');
                    cenv(locid1, tq^.tenv);
                    tq := tq^.tnext
                    end;
                writeln;
                if tp^.twithstmt^.tt = nbegin then
                    estmt(tp^.twithstmt^.tbegin)
                else
                    estmt(tp^.twithstmt);
                decrement;
                indent;
                writeln('}')
                end;
              ngoto:
                begin
                indent;
                if islocal(tp^.tlabel) then
                    writeln('goto L',
                        tp^.tlabel^.tsym^.lno:1, ';')
                else begin
                    tq := idup(tp^.tlabel);
                    writeln('longjmp(J[',    (* LIB *)
                        tq^.tstat:1, '].jb, ',
                        tp^.tlabel^.tsym^.lno:1, ');')
                     end
                end;
              nlabstmt:
                begin
                decrement;
                indent;
                writeln('L', tp^.tlabno^.tsym^.lno:1, ':');
                increment;
                estmt(tp^.tstmt)
                end;
              nassign:
                begin
                indent;
                eexpr(tp);
                writeln(';')
                end;
              ncall:
                begin
                indent;
                tq := idup(tp^.tcall);
                if (tq^.tt in [nfunc, nproc]) and
                        (tq^.tsubstmt <> nil) then
                    if tq^.tsubstmt^.tt = npredef then
                        epredef(tq, tp)
                    else begin
                        ecall(tp);
                        writeln(';')
                         end
                else begin
                    ecall(tp);
                    writeln(';')
                     end
                end;
              npush:
                begin
                indent;
                eglobid(tp^.ttmp);
                write(' = ');
                eglobid(tp^.tglob);
                writeln(';');
                indent;
                eglobid(tp^.tglob);
                write(' = ');
                if tp^.tloc^.tt = nid then
                    begin
                    tq := idup(tp^.tloc);
                    if tq^.tt in [nparproc, nparfunc] then
                        printid(tp^.tloc^.tsym^.lid)
                    else
                        eaddr(tp^.tloc)
                    end
                else
                    eaddr(tp^.tloc);
                writeln(';')
                end;
              npop:
                begin
                indent;
                eglobid(tp^.tglob);
                write(' = ');
                eglobid(tp^.ttmp);
                writeln(';')
                end;
              nbreak:
                begin
                indent;
                write('if (');
                eexpr(tp^.tbrkid);
                write(' == ');
                eexpr(tp^.tbrkxp);
                writeln(') break;')
                end;
              nempty:
                if not (tp^.tup^.tt in [npgm, nproc, nfunc,
                        nchoise, nbegin, nrepeat]) then
                    begin
                    indent;
                    writeln(';')
                    end
            end;(* case *)
            if setused and
                (tp^.tup^.tt in [npgm, nproc, nfunc, nrepeat,
                        nbegin, nchoise, nwith]) then
                begin
                indent;
                writeln('Claimset();');
                setused := false
                end;
            tp := tp^.tnext
            end
    end;    (* estmt *)

    (*    Emit initialization for non-local gotos.        *)
    procedure elabel(tp : treeptr);

    var    tq    : treeptr;
        i    : integer;

    begin
        i := 0;
        tq := tp^.tsublab;
        while tq <> nil do
            begin
            if tq^.tsym^.lgo then
                i := i + 1;
            tq := tq^.tnext
            end;
        if i =1 then
            begin
            tq := tp^.tsublab;
            while not tq^.tsym^.lgo do
                tq := tq^.tnext;
            indent;
            writeln('if (',
                'setjmp(J[', tp^.tstat:1, '].jb))'); (* LIB *)
            writeln(tab1, 'goto L', tq^.tsym^.lno:1, ';')
            end
        else if i > 1 then
            begin
            indent;
            writeln('switch (',
                'setjmp(J[', tp^.tstat:1, '].jb)) {'); (* LIB *)
            indent;
            writeln('  case 0:');
            indent;
            writeln(tab1, 'break');
            tq := tp^.tsublab;
            while tq <> nil do
                begin
                if tq^.tsym^.lgo then
                    begin
                    (* label used in non-local goto *)
                    indent;
                    writeln('  case ',
                            tq^.tsym^.lno:1, ':');
                    indent;
                    writeln(tab1, 'goto L',
                            tq^.tsym^.lno:1, ';')
                    end;
                tq := tq^.tnext
                end;
            indent;
            writeln('  default:');
            indent;
            writeln(tab1, 'Caseerror(Line)');
            indent;
            writeln('}')
            end
    end;    (* elabel *)

    (*    Emit declaration for lower bound of conformant array.    *)
    procedure econf(tp : treeptr);

    var    tq    : treeptr;

    begin
        while tp <> nil do
            begin
            if tp^.tt = nvarpar then
                if tp^.tbind^.tt = nconfarr then
                    begin
                    indent;
                    etypedef(tp^.tbind^.tindtyp);
                    write(tab1);
                    tq := tp^.tbind^.tcindx^.tlo;
                    printid(tq^.tsym^.lid);
                    write(' = (');
                    etypedef(tp^.tbind^.tindtyp);
                    writeln(')0;')
                    end;
            tp := tp^.tnext
            end
    end;    (* econf *)

    (*    Emit code for subroutines.                *)
    procedure esubr(tp : treeptr);

    label    999;

    var    tq, ti    : treeptr;

    begin
        while tp <> nil do
            begin
            (* emit nested subroutines *)
            if tp^.tsubsub <> nil then
                begin
                (* emit forward declaration of this subroutine
                   in case of recursion *)
                etypedef(tp^.tfuntyp);
                write(space);
                printid(tp^.tsubid^.tsym^.lid);
                writeln('();');
                writeln;
                esubr(tp^.tsubsub)
                end;
            (* emit this subroutine *)
            if tp^.tsubstmt = nil then
                begin
                (* forward/external decl *)
                if tp^.tsubid^.tsym^.lsymdecl^.tup = tp then
                    write(xtern);
                etypedef(tp^.tfuntyp);
                write(space);
                printid(tp^.tsubid^.tsym^.lid);
                writeln('();');
                goto 999
                end;
            write(space);
            etypedef(tp^.tfuntyp);
            writeln;
            printid(tp^.tsubid^.tsym^.lid);
            write('(');
            tq := tp^.tsubpar;
            while tq <> nil do
                begin
                case tq^.tt of
                  nvarpar,
                  nvalpar:
                    begin
                    ti := tq^.tidl;
                    while ti <> nil do
                        begin
                        printid(ti^.tsym^.lid);
                        ti := ti^.tnext;
                        if ti <> nil then
                            write(', ');
                        end;
                    if tq^.tbind^.tt = nconfarr then
                        begin
                        (* add upper bound parameter *)
                        ti := tq^.tbind^.tcindx^.thi;
                        write(', ');
                        printid(ti^.tsym^.lid)
                        end;
                    end;
                  nparproc,
                  nparfunc:
                    begin
                    ti := tq^.tparid;
                    printid(ti^.tsym^.lid)
                    end
                end;(* case *)
                tq := tq^.tnext;
                if tq <> nil then
                    write(', ');
                end;
            writeln(')');
            increment;
            evar(tp^.tsubpar);
            writeln('{');
            econf(tp^.tsubpar);
            econst(tp^.tsubconst);
            etype(tp^.tsubtype);
            evar(tp^.tsubvar);

            if (tp^.tsubconst <> nil) or (tp^.tsubtype <> nil) or
                    (tp^.tsubvar <> nil) then
                writeln;
            elabel(tp);
            estmt(tp^.tsubstmt);
            if tp^.tt = nfunc then
                begin
                (* return value in the FIRST variable,
                   see renamf() above *)
                indent;
                write('return ');
                printid(tp^.tsubvar^.tidl^.tsym^.lid);
                writeln(';');
                end;
            decrement;
            writeln('}');
        999:
            writeln;
            tp := tp^.tnext
            end
    end;    (* esubr *)

    function use(d : predefs) : boolean;

    begin
        use := defnams[d]^.lused
    end;

    (*    Emit code for main program.                *)
    procedure eprogram(tp : treeptr);

        (*    Symbol that sp refers to is renamed if it has    *)
        (*    been redefined in source program.        *)
        procedure capital(sp : symptr);

        var    tb    : toknbuf;

        begin
            if sp^.lid^.inref > 1 then
                begin
                gettokn(sp^.lid^.istr, tb);
                tb[1] := uppercase(tb[1]);
                sp^.lid := saveid(tb)
                end
        end;

        procedure etextdef;

        var    tq    : treeptr;

        begin
            write('typedef ');
            tq := mknode(nfileof);
            tq^.tof := typnods[tchar];
            etypedef(tq);
            writeln(tab1, 'text;')
        end;

    begin    (* eprogram *)
        if tp^.tsubid <> nil then
            begin
            (* program heading was seen *)
            writeln('/', '*');
            write('**    Code derived from program ');
            printid(tp^.tsubid^.tsym^.lid);
            writeln;
            writeln('*', '/');
            writeln(xtern, voidtyp, tab1, 'exit();')
            end;
        if usecase or usesets or
           use(dinput) or use(doutput) or
           use(dwrite) or use(dwriteln) or use(dmessage) or
           use(deof) or use(deoln) or use(dflush) or use(dpage) or
           use(dread) or use(dreadln) or use(dclose) or
           use(dreset) or use(drewrite) or use(dget) or use(dput) then
            begin
            writeln('/', '*');
            writeln('**    Definitions for i/o');
            writeln('*', '/');
            writeln(include, '<stdio.h>')    (* LIB *)
            end;
        if use(dinput) or use(doutput) or use(dtext) then
            begin
            etextdef;
            if use(dinput) then
                begin
                if tp^.tsubid = nil then
                    write(xtern);
                write('text', tab1);
                printid(defnams[dinput]^.lid);
                if tp^.tsubid <> nil then
                    write(' = { stdin, 0, 0 }');
                writeln(';')
                end;
            if use(doutput) then
                begin
                if tp^.tsubid = nil then
                    write(xtern);
                write('text', tab1);
                printid(defnams[doutput]^.lid);
                if tp^.tsubid <> nil then
                    write(' = { stdout, 0, 0 }');
                writeln(';')
                end
            end;
        if use(dinput) or use(dget) or use(dread) or use(dreadln) or
           use(deof) or use(deoln) or use(dreset) or use(drewrite) then
            begin
            writeln(define, 'Fread(x, f) ',
                'fread((char *)&x, sizeof(x), 1, f)'); (* LIB *)
            writeln(define, 'Get(f) Fread((f).buf, (f).fp)');
            writeln(define, 'Getx(f) (f).init = 1, ',
                '(f).eoln = (((f).buf = ',
                    'fgetc((f).fp)',    (* LIB *)
                    ') == ', nlchr, ') ? (((f).buf = ',
                        spchr, '), 1) : 0');
            writeln(define, 'Getchr(f) (f).buf, Getx(f)')
            end;
        if use(dread) or use(dreadln) then
            begin
            writeln(static, 'FILE', tab1, '*Tmpfil;');
            writeln(static, 'long', tab1, 'Tmplng;');
            writeln(static, 'double', tab1, 'Tmpdbl;');
            writeln(define, 'Fscan(f) (f).init ? ',
                'ungetc((f).buf, (f).fp)',    (* LIB *)
                    ' : 0, Tmpfil = (f).fp');
            writeln(define, 'Scan(p, a) ',
                'Scanck(fscanf(Tmpfil, p, a))'); (* LIB *)
            writeln(voidtyp, tab1, 'Scanck();');
            if use(dreadln) then
                writeln(voidtyp, tab1, 'Getl();');
            end;
        if use(deoln) then
            writeln(define, 'Eoln(f) ((f).eoln ? true : false)');
        if use(deof) then
            writeln(define, 'Eof(f) ',
                '((((f).init == 0) ? (Get(f)) : 0, ',
                    '((f).eof ? 1 : ',
                        'feof((f).fp))) ? ', (* LIB *)
                            'true : false)');
        if use(doutput) or use(dput) or
                use(dwrite) or use(dwriteln) or
                use(dreset) or use(drewrite) or use(dclose) then
            begin
            writeln(define, 'Fwrite(x, f) ',
                'fwrite((char *)&x, sizeof(x), 1, f)');(* LIB *)
            writeln(define, 'Put(f) Fwrite((f).buf, (f).fp)');
            writeln(define, 'Putx(f) (f).eoln = ((f).buf == ',
                nlchr, '), ', voidcast,
                'fputc((f).buf, (f).fp)'); (* LIB *)
            writeln(define, 'Putchr(c, f) (f).buf = (c), Putx(f)');
            writeln(define, 'Putl(f, v) (f).eoln = v')
            end;
        if use(dreset) or use(drewrite) or use(dclose) then
            writeln(define, 'Finish(f) ((f).out && !(f).eoln) ? ',
                '(Putchr(', nlchr, ', f), 0) : 0, ',
                    'rewind((f).fp)');    (* LIB *)
        if use(dclose) then
            begin
            writeln(define, 'Close(f) (f).init = ',
                '((f).init ? (',
                    'fclose((f).fp), ',    (* LIB *)
                        '0) : 0), (f).fp = NULL');
            writeln(define, 'Closex(f) (f).init = ',
                '((f).init ? ',
                    '(Finish(f), ',
                    'fclose((f).fp), ',    (* LIB *)
                        '0) : 0), (f).fp = NULL')
            end;
        if use(dreset) then
            begin
            writeln(ifdef, 'READONLY');
            writeln(static, chartyp, tab1, 'Rmode[] = "r";');
            writeln(elsif);
            writeln(static, chartyp, tab1, 'Rmode[] = "r+";');
            writeln(endif);
            writeln(define, 'Reset(f, n) (f).init = ',
                '(f).init ? rewind((f).fp) : ',    (* LIB *)
                '(((f).fp = Fopen(n, Rmode)), 1), ',
                    '(f).eof = (f).out = 0, Get(f)');
            writeln(define, 'Resetx(f, n) (f).init = ',
                '(f).init ? (Finish(f)) : ',
                '(((f).fp = Fopen(n, Rmode)), 1), ',
                    '(f).eof = (f).out = 0, Getx(f)');
            usefopn := true
            end;
        if use(drewrite) then
            begin
            writeln(ifdef, 'WRITEONLY');
            writeln(static, chartyp, tab1, 'Wmode[] = "w";');
            writeln(elsif);
            writeln(static, chartyp, tab1, 'Wmode[] = "w+";');
            writeln(endif);
            writeln(define, 'Rewrite(f, n) (f).init = ',
                '(f).init ? rewind((f).fp) : ',    (* LIB *)
                '(((f).fp = Fopen(n, Wmode)), 1), ',
                    '(f).out = (f).eof = 1');
            writeln(define, 'Rewritex(f, n) (f).init = ',
                '(f).init ? (Finish(f)) : ',
                '(((f).fp = Fopen(n, Wmode)), 1), ',
                    '(f).out = (f).eof = (f).eoln = 1');
            usefopn := true
            end;
        if usefopn then
            begin
            writeln('FILE    *Fopen();');
            writeln(define, 'MAXFILENAME 256')
            end;
        if usecase or usejmps then
            begin
            writeln('/', '*');
            writeln('**    Definitions for case-statements');
            writeln('**    and for non-local gotos');
            writeln('*', '/');
            writeln(define, 'Line __LINE__');
            writeln(voidtyp, tab1, 'Caseerror();')
            end;
        if usejmps then
            begin
            writeln(include, '<setjmp.h>');    (* LIB *)
            writeln(static, 'struct Jb { jmp_buf', tab1, 'jb; } J[',
                            (maxlevel+1):1, '];')
            end;
        if use(dinteger) or use(dmaxint) or
            use(dboolean) or use(dfalse) or use(dtrue) or
                use(deof) or use(deoln) or use(dexp) or
                use(dln) or use(dsqr) or use(dsin) or
                use(dcos) or use(dtan) or use(darctan) or
                use(dsqrt) or use(dreal) then
            begin
            writeln('/', '*');
            writeln('**    Definitions for standard types');
            writeln('*', '/')
            end;
        if usecomp then
            begin
            writeln(xtern, inttyp, ' strncmp();');    (* LIB *)
            writeln(define,
                'Cmpstr(x, y) ',
                'strncmp((x), (y), sizeof(x))')    (* LIB *)
            end;
        if use(dboolean) or use(dfalse) or use(dtrue) or
            use(deof) or use(deoln) or usesets then
            begin
            capital(defnams[dboolean]);
            write(typdef, chartyp, tab1);
            printid(defnams[dboolean]^.lid);
            writeln(';');
            capital(defnams[dfalse]);
            write(define);
            printid(defnams[dfalse]^.lid);
            write(' (');
            printid(defnams[dboolean]^.lid);
            writeln(')0');
            capital(defnams[dtrue]);
            write(define);
            printid(defnams[dtrue]^.lid);
            write(' (');
            printid(defnams[dboolean]^.lid);
            writeln(')1');
            writeln(xtern, chartyp, tab1, '*Bools[];')
            end;
        capital(defnams[dinteger]);
        if use(dinteger) then
            begin
            write(typdef, inttyp, tab1);
            printid(defnams[dinteger]^.lid);
            writeln(';')
            end;
        if use(dmaxint) then
            writeln(define, 'maxint', tab1, maxint:1);
        capital(defnams[dreal]);
        if use(dreal) then
            begin
            write(typdef, realtyp, tab1);
            printid(defnams[dreal]^.lid);
            writeln(';')
            end;
        if use(dexp) then
            writeln(xtern, doubletyp, ' exp();');    (* LIB *)
        if use(dln) then
            writeln(xtern, doubletyp, ' log();');    (* LIB *)
        if use(dsqr) then
            writeln(xtern, doubletyp, ' pow();');    (* LIB *)
        if use(dsin) then
            writeln(xtern, doubletyp, ' sin();');    (* LIB *)
        if use(dcos) then
            writeln(xtern, doubletyp, ' cos();');    (* LIB *)
        if use(dtan) then
            writeln(xtern, doubletyp, ' tan();');    (* LIB *)
        if use(darctan) then
            writeln(xtern, doubletyp, ' atan();');    (* LIB *)
        if use(dsqrt) then
            writeln(xtern, doubletyp, ' sqrt();');    (* LIB *)
        if use(dabs) and use(dreal) then
            writeln(xtern, doubletyp, ' fabs();');    (* LIB *)
        if use(dhalt) then
            writeln(xtern, voidtyp, ' abort();');    (* LIB *)
        if use(dnew) or usenilp then
            begin
            writeln('/', '*');
            writeln('**    Definitions for pointers');
            writeln('*', '/');
            end;
        if use(dnew) then
            begin
            writeln(ifndef, 'Unionoffs');
            writeln(define, 'Unionoffs(p, m) ',
                '(((long)(&(p)->m))-((long)(p)))');    (* CPU *)
            writeln(endif)
            end;
        if usenilp then
            writeln(define, 'NIL 0');        (* CPU *)
        if use(dnew) then
            writeln(xtern, chartyp, ' *malloc();');    (* LIB *)
        if use(ddispose) then
            writeln(xtern, voidtyp, ' free();');    (* LIB *)
        if usesets then
            begin
            writeln('/', '*');
            writeln('**    Definitions for set-operations');
            writeln('*', '/');
            writeln(define, 'Claimset() ',
                voidcast, 'Currset(0, (', setptyp, ')0)');
            writeln(define, 'Newset() ',
                    'Currset(1, (', setptyp, ')0)');
            writeln(define, 'Saveset(s) Currset(2, s)');
            writeln(define, 'setbits ', setbits:1);
            writeln(typdef, wordtype, tab1, setwtyp, ';');
            writeln(typdef, setwtyp, ' *', tab1, setptyp, ';');
            printid(defnams[dboolean]^.lid);
            writeln(tab1, 'Member(), Le(), Ge(), Eq(), Ne();');
            writeln(setptyp, tab1, 'Union(), Diff();');
            writeln(setptyp, tab1, 'Insmem(), Mksubr();');
            writeln(setptyp, tab1, 'Currset(), Inter();');
            writeln(static, setptyp, tab1, 'Tmpset;');
            writeln(xtern, setptyp, tab1, 'Conset[];');
            writeln(voidtyp, tab1, 'Setncpy();')
            end;
        writeln(xtern, chartyp, ' *strncpy();');    (* LIB *)
        if use(dargc) or use(dargv) then
            begin
            writeln('/', '*');
            writeln('**    Definitions for argv-operations');
            writeln('*', '/');
            writeln(inttyp, tab1, 'argc;');        (* OS *)
            writeln(chartyp, tab1, '**argv;');
            writeln(' void');
            writeln('Argvgt(n, cp, l)');
            writeln(inttyp, tab1, 'n;');
            writeln(registr, inttyp, tab1, 'l;');
            writeln(registr, chartyp, tab1, '*cp;');
            writeln('{');
            writeln(tab1, registr, chartyp, tab1, '*sp;');
            writeln;
            writeln(tab1, 'for (sp = argv[n]; l > 0 && *sp; l--)');
            writeln(tab2, '*cp++ = *sp++;');
            writeln(tab1, 'while (l-- > 0)');
            writeln(tab2, '*cp++ = ', spchr, ';');
            writeln('}');
            end;
        if (tp^.tsubconst <> nil) or (tp^.tsubtype<> nil) or
            (tp^.tsubvar <> nil) or (tp^.tsubsub <> nil) then
            begin
            writeln('/', '*');
            writeln('**    Start of program definitions');
            writeln('*', '/');
            end;
        econst(tp^.tsubconst);
        etype(tp^.tsubtype);
        evar(tp^.tsubvar);
        if tp^.tsubsub <> nil then
            writeln;
        esubr(tp^.tsubsub);
        if tp^.tsubid <> nil then
            begin
            (* program heading was seen *)
            writeln('/', '*');
            writeln('**    Start of program code');
            writeln('*', '/');
            if use(dargc) or use(dargv) then
                begin
                writeln('main(_ac, _av)');    (* OS *)
                writeln(inttyp, tab1, '_ac;');
                writeln(chartyp, tab1, '*_av[];');
                writeln('{');
                writeln;
                writeln(tab1, 'argc = _ac;');
                writeln(tab1, 'argv = _av;')
                end
            else begin
                writeln('main()');
                writeln('{')
                 end;
            increment;
            elabel(tp);
            estmt(tp^.tsubstmt);
            indent;
            writeln('exit(0);');
            decrement;
            writeln('}');
            writeln('/', '*');
            writeln('**    End of program code');
            writeln('*', '/')
            end
    end;    (* eprogram *)

    (*    Emit definitions for constant sets    *)
    procedure econset(tp : treeptr; len : integer);

    var    i    : integer;

        function size(tp : treeptr) : integer;

        var    r, x    : integer;

        begin
            r := 0;
            while tp <> nil do
                begin
                if tp^.tt = nrange then
                    x := cvalof(tp^.texpr)
                else if tp^.tt = nempty then
                    x := 0
                else
                    x := cvalof(tp);
                if x > r then
                    r := x;
                tp := tp^.tnext
                end;
            size := csetwords(r+1)
        end;

        (*    Emit bits in a constant set    *)
        procedure ebits(tp : treeptr);

        type    bitset    = set of 0 .. setbits;

        var    sets    : array [ 0 .. maxsetrange ] of bitset;
            s, m, n    : integer;

            procedure eword(s : bitset);

            const    bitshex    = 4;    (* nr of bits in a hex-digit *)

            var    n, i    : integer;
                x    : 0 .. setbits;

            begin
                n := 0;
                while n <= setbits do
                    n := n + bitshex;
                n := n - bitshex;
                while n >= 0 do
                    begin
                    (* compute 1 hexdigit *)
                    x := 0;
                    for i := 0 to bitshex - 1 do
                        if (n + i) in s then
                            case i of
                              0:    x := x + 1;
                              1:    x := x + 2;
                              2:    x := x + 4;
                              3:    x := x + 8
                            end;(* case *)
                    (* print it *)
                    write(hexdig[x]);
                    n := n - bitshex
                    end
            end;

        begin
            s := size(tp);
            for n := 0 to s - 1 do
                sets[n] := [];
            while tp <> nil do
                begin
                if tp^.tt = nrange then
                    for m := cvalof(tp^.texpl) to
                            cvalof(tp^.texpr) do
                        begin
                        n := m div (setbits+1);
                        sets[n] := sets[n] +
                            [m mod (setbits+1)]
                        end
                else if tp^.tt <> nempty then
                    begin
                    m := cvalof(tp);
                    n := m div (setbits+1);
                    sets[n] := sets[n] +
                        [m mod (setbits+1)]
                    end;
                tp := tp^.tnext
                end;
            write(tab1, s:1);
            for n := 0 to s - 1 do
                begin
                write(',');
                if n mod 6 = 0 then
                    writeln;
                write(tab1, '0x');
                eword(sets[n]);
                end;
            writeln
        end;

    begin
        i := 0;
        while tp <> nil do
            begin
            writeln(static, setwtyp, tab1, 'Q', i:1, '[] = {');
            ebits(tp^.texps);
            writeln('};');
            i := i + 1;
            tp := tp^.tnext
            end;
        writeln(static, setwtyp, tab1, '*Conset[] = {');
        for i := len - 1 downto 1 do
            begin
            write(tab1, 'Q', i:1, ',');
            if i mod 6 = 5 then
                writeln
            end;
        writeln(tab1, 'Q0');
        writeln('};');
    end;

begin    (* emit *)
    indnt := 0;
    varno := 0;
    conflag := false;
    setused := false;
    dropset := false;
    doarrow := 0;
    eprogram(top);
    if usebool then
        writeln(chartyp, tab1, '*Bools[] = { "false", "true" };');
    if usescan then
        begin
        writeln;
        writeln(static, voidtyp);
        writeln('Scanck(n)');
        writeln(inttyp, tab1, 'n;');
        writeln('{');
        writeln(tab1, 'if (n != 1) {');
        writeln(tab2, voidcast, 'fprintf(stderr, "Bad input\n");');
        writeln(tab2, 'exit(1);');
        writeln(tab1, '}');
        writeln('}')
        end;
    if usegetl then
        begin
        writeln;
        writeln(static, voidtyp);
        writeln('Getl(f)');
        writeln(' text', tab1, '*f;');
        writeln('{');
        writeln(tab1, 'while (f->eoln == 0)');
        writeln(tab2, 'Getx(*f);');
        writeln(tab1, 'Getx(*f);');
        writeln('}')
        end;
    if usefopn then
        begin
        writeln;
        writeln(static, 'FILE *');
        writeln('Fopen(n, m)');
        writeln(chartyp, tab1, '*n, *m;');
        writeln('{');
        writeln(tab1, 'FILE', tab2, '*f;');
        writeln(tab1, registr, chartyp, tab1, '*s;');
        writeln(tab1, static, chartyp, tab1, 'ch = ',
                        quote, 'A', quote, ';');
        writeln(tab1, static, chartyp, tab1, 'tmp[MAXFILENAME];');
        writeln(tab1, xtern , inttyp, tab1, 'unlink();'); (* OS *)
        writeln;
        writeln(tab1, 'if (n == NULL)');
        writeln(tab2, 'sprintf(tmp, ', tmpfilename, 'ch++);');
        writeln(tab1, 'else {');
        writeln(tab2, 'strncpy(tmp, n, sizeof(tmp));');
        writeln(tab2, 'for (s = &tmp[sizeof(tmp)-1]; *s == ',
            spchr, ' || *s == ', nulchr, '; )');
        writeln(tab3, '*s-- = ', nulchr, ';');
        writeln(tab2, 'if (tmp[sizeof(tmp)-1]) {');
        writeln(tab3, voidcast, 'fprintf(stderr, "Too long filename ',
            quote, '%s', quote, '\n", n);');
        writeln(tab3, 'exit(1);');
        writeln(tab2, '}');
        writeln(tab1, '}');
        writeln(tab1, 's = tmp;');
        writeln(tab1, 'if ((f = fopen(s, m)) == NULL) {');
        writeln(tab2, voidcast,
                'fprintf(stderr, "Cannot open: %s\n", s);');
        writeln(tab2, 'exit(1);');
        writeln(tab1, '}');
        writeln(tab1, 'if (n == NULL)');
        writeln(tab2, 'unlink(tmp);');    (* OS *)
        writeln(tab1, 'return (f);');
        writeln('}');
        writeln(xtern, inttyp, tab1, 'rewind();')
        end;
    if setcnt > 0 then
        econset(setlst, setcnt);
    if useunion then
        begin
        writeln;
        writeln(static, setptyp);
        writeln('Union(p1, p2)');
        writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
        writeln('{');
        writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
        writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
        writeln(tab4, 'p3 = sp;');
        writeln;
        writeln(tab1, 'j = *p1;');
        writeln(tab1, '*p3 = j;');
        writeln(tab1, 'if (j > *p2)');
        writeln(tab2, 'j = *p2;');
        writeln(tab1, 'else');
        writeln(tab2, '*p3 = *p2;');
        writeln(tab1, 'k = *p1 - *p2;');
        writeln(tab1, 'p1++, p2++, p3++;');
        writeln(tab1, 'for (i = 0; i < j; i++)');
        writeln(tab2, '*p3++ = (*p1++ | *p2++);');
        writeln(tab1, 'while (k > 0) {');
        writeln(tab2, '*p3++ = *p1++;');
        writeln(tab2, 'k--;');
        writeln(tab1, '}');
        writeln(tab1, 'while (k < 0) {');
        writeln(tab2, '*p3++ = *p2++;');
        writeln(tab2, 'k++;');
        writeln(tab1, '}');
        writeln(tab1, 'return (Saveset(sp));');
        writeln('}')
        end;
    if usediff then
        begin
        writeln;
        writeln(static, setptyp);
        writeln('Diff(p1, p2)');
        writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
        writeln('{');
        writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
        writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
        writeln(tab4, 'p3 = sp;');
        writeln;
        writeln(tab1, 'j = *p1;');
        writeln(tab1, '*p3 = j;');
        writeln(tab1, 'if (j > *p2)');
        writeln(tab2, 'j = *p2;');
        writeln(tab1, 'k = *p1 - *p2;');
        writeln(tab1, 'p1++, p2++, p3++;');
        writeln(tab1, 'for (i = 0; i < j; i++)');
        writeln(tab2, '*p3++ = (*p1++ & ~ (*p2++));');
        writeln(tab1, 'while (k > 0) {');
        writeln(tab2, '*p3++ = *p1++;');
        writeln(tab2, 'k--;');
        writeln(tab1, '}');
        writeln(tab1, 'return (Saveset(sp));');
        writeln('}')
        end;
    if useintr then
        begin
        writeln;
        writeln(static, setptyp);
        writeln('Inter(p1, p2)');
        writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
        writeln('{');
        writeln(tab1, registr, inttyp, tab2, 'i, j, k;');
        writeln(tab1, registr, setptyp, tab2, 'sp = Newset(),');
        writeln(tab4, 'p3 = sp;');
        writeln;
        writeln(tab1, 'if ((j = *p1) > *p2)');
        writeln(tab2, 'j = *p2;');
        writeln(tab1, '*p3 = j;');
        writeln(tab1, 'p1++, p2++, p3++;');
        writeln(tab1, 'for (i = 0; i < j; i++)');
        writeln(tab2, '*p3++ = (*p1++ & *p2++);');
        writeln(tab1, 'return (Saveset(sp));');
        writeln('}')
        end;
    if usememb then
        begin
        writeln;
        write(static);
        printid(defnams[dboolean]^.lid);
        writeln;
        writeln('Member(m, sp)');
        writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
        writeln(tab1, registr, setptyp, tab1, 'sp;');
        writeln('{');
        writeln(tab1, registr, usigned, inttyp,
                    tab1, 'i = m / (setbits+1) + 1;');
        writeln;
        writeln(tab1, 'if ((i <= *sp) &&',
                    ' (sp[i] & (1 << (m % (setbits+1)))))');
        write(tab2, 'return (');
        printid(defnams[dtrue]^.lid);
        writeln(');');
        write(tab1, 'return (');
        printid(defnams[dfalse]^.lid);
        writeln(');');
        writeln('}')
        end;
    if useseq or usesne then
        begin
        writeln;
        write(static);
        printid(defnams[dboolean]^.lid);
        writeln;
        writeln('Eq(p1, p2)');
        writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
        writeln('{');
        writeln(tab1, registr, inttyp, tab1, 'i, j;');
        writeln;
        writeln(tab1, 'i = *p1++;');
        writeln(tab1, 'j = *p2++;');
        writeln(tab1, 'while (i != 0 && j != 0) {');
        writeln(tab2, 'if (*p1++ != *p2++)');
        write(tab3, 'return (');
        printid(defnams[dfalse]^.lid);
        writeln(');');
        writeln(tab2, 'i--, j--;');
        writeln(tab1, '}');
        writeln(tab1, 'while (i != 0) {');
        writeln(tab2, 'if (*p1++ != 0)');
        write(tab3, 'return (');
        printid(defnams[dfalse]^.lid);
        writeln(');');
        writeln(tab2, 'i--;');
        writeln(tab1, '}');
        writeln(tab1, 'while (j != 0) {');
        writeln(tab2, 'if (*p2++ != 0)');
        write(tab3, 'return (');
        printid(defnams[dfalse]^.lid);
        writeln(');');
        writeln(tab2, 'j--;');
        writeln(tab1, '}');
        write(tab1, 'return (');
        printid(defnams[dtrue]^.lid);
        writeln(');');
        writeln('}')
        end;
    if usesne then
        begin
        writeln;
        write(static);
        printid(defnams[dboolean]^.lid);
        writeln;
        writeln('Ne(p1, p2)');
        writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
        writeln('{');
        write(tab1, 'return (!Eq(p1, p2));');
        writeln('}')
        end;
    if usesle then
        begin
        writeln;
        write(static);
        printid(defnams[dboolean]^.lid);
        writeln;
        writeln('Le(p1, p2)');
        writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
        writeln('{');
        writeln(tab1, registr, inttyp, tab1, 'i, j;');
        writeln;
        writeln(tab1, 'i = *p1++;');
        writeln(tab1, 'j = *p2++;');
        writeln(tab1, 'while (i != 0 && j != 0) {');
        writeln(tab2, 'if ((*p1++ & ~ *p2++) != 0)');
        write(tab3, 'return (');
        printid(defnams[dfalse]^.lid);
        writeln(');');
        writeln(tab2, 'i--, j--;');
        writeln(tab1, '}');
        writeln(tab1, 'while (i != 0) {');
        writeln(tab2, 'if (*p1++ != 0)');
        write(tab3, 'return (');
        printid(defnams[dfalse]^.lid);
        writeln(');');
        writeln(tab2, 'i--;');
        writeln(tab1, '}');
        write(tab1, 'return (');
        printid(defnams[dtrue]^.lid);
        writeln(');');
        writeln('}')
        end;
    if usesge then
        begin
        writeln;
        write(static);
        printid(defnams[dboolean]^.lid);
        writeln;
        writeln('Ge(p1, p2)');
        writeln(tab1, registr, setptyp, tab1, 'p1, p2;');
        writeln('{');
        writeln(tab1, registr, inttyp, tab1, 'i, j;');
        writeln;
        writeln(tab1, 'i = *p1++;');
        writeln(tab1, 'j = *p2++;');
        writeln(tab1, 'while (i != 0 && j != 0) {');
        writeln(tab2, 'if ((*p2++ & ~ *p1++) != 0)');
        writeln(tab3, 'return (false);');
        writeln(tab2, 'i--, j--;');
        writeln(tab1, '}');
        writeln(tab1, 'while (j != 0) {');
        writeln(tab2, 'if (*p2++ != 0)');
        write(tab3, 'return (');
        printid(defnams[dfalse]^.lid);
        writeln(');');
        writeln(tab2, 'j--;');
        writeln(tab1, '}');
        write(tab1, 'return (');
        printid(defnams[dtrue]^.lid);
        writeln(');');
        writeln('}')
        end;
    if usemksub then
        begin
        writeln;
        writeln(static, setptyp);
        writeln('Mksubr(lo, hi, sp)');
        writeln(tab1, registr, usigned, inttyp, tab1, 'lo, hi;');
        writeln(tab1, registr, setptyp, tab1, 'sp;');
        writeln('{');
        writeln(tab1, registr, inttyp, tab1, 'i, k;');
        writeln;
        writeln(tab1, 'if (hi < lo)');
        writeln(tab2, 'return (sp);');
        writeln(tab1, 'i = hi / (setbits+1) + 1;');
        writeln(tab1, 'for (k = *sp + 1; k <= i; k++)');
        writeln(tab2, 'sp[k] = 0;');
        writeln(tab1, 'if (*sp < i)');
        writeln(tab2, '*sp = i;');
        writeln(tab1, 'for (k = lo; k <= hi; k++)');
        writeln(tab2, 'sp[k / (setbits+1) + 1] |= ',
                        '(1 << (k % (setbits+1)));');
        writeln(tab1, 'return (sp);');
        writeln('}')
        end;
    if useins then
        begin
        writeln;
        writeln(static, setptyp);
        writeln('Insmem(m, sp)');
        writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
        writeln(tab1, registr, setptyp, tab1, 'sp;');
        writeln('{');
        writeln(tab1, registr, inttyp, tab1, 'i,');
        writeln(tab3, tab1, 'j = m / (setbits+1) + 1;');
        writeln;
        writeln(tab1, 'if (*sp < j)');
        writeln(tab2, 'for (i = *sp + 1, *sp = j; i <= *sp; i++)');
        writeln(tab3, 'sp[i] = 0;');
        writeln(tab1, 'sp[j] |= (1 << (m % (setbits+1)));');
        writeln(tab1, 'return (sp);');
        writeln('}')
        end;
    if usesets then
        begin
        writeln;
        writeln(ifndef, 'SETSPACE');
        writeln(define, 'SETSPACE 256');
        writeln(endif);
        writeln(static, setptyp);
        writeln('Currset(n,sp)');
        writeln(tab1, inttyp, tab1, 'n;');
        writeln(tab1, setptyp, tab1, 'sp;');
        writeln('{');
        writeln(tab1, static, setwtyp, tab1, 'Space[SETSPACE];');
        writeln(tab1, static, setptyp, tab1, 'Top = Space;');
        writeln;
        writeln(tab1, 'switch (n) {');
        writeln(tab1, '  case 0:');
        writeln(tab2, 'Top = Space;');
        writeln(tab2, 'return (0);');
        writeln(tab1, '  case 1:');
        writeln(tab2, 'if (&Space[SETSPACE] - Top <= ',
                            maxsetrange:1, ') {');
        writeln(tab3,
            voidcast, 'fprintf(stderr, "Set-space exhausted\n");');
        writeln(tab3, 'exit(1);');
        writeln(tab2, '}');
        writeln(tab2, '*Top = 0;');
        writeln(tab2, 'return (Top);');
        writeln(tab1, '  case 2:');
        writeln(tab2, 'if (Top <= &sp[*sp])');
        writeln(tab3, 'Top = &sp[*sp + 1];');
        writeln(tab2, 'return (sp);');
        writeln(tab1, '}');
        writeln(tab1, '/', '* NOTREACHED *', '/');
        writeln('}')
        end;
    if usescpy then
        begin
        writeln;
        writeln(static, voidtyp);
        writeln('Setncpy(S1, S2, N)');
        writeln(tab1, registr, setptyp, tab1, 'S1, S2;');
        writeln(tab1, registr, usigned, inttyp, tab1, 'N;');
        writeln('{');
        writeln(tab1, registr, usigned, inttyp, tab1, 'm;');
        writeln;
        writeln(tab1, 'N /= sizeof(', setwtyp, ');');
        writeln(tab1, '*S1++ = --N;');
        writeln(tab1, 'm = *S2++;');
        writeln(tab1, 'while (m != 0 && N != 0) {');
        writeln(tab2, '*S1++ = *S2++;');
        writeln(tab2, '--N;');
        writeln(tab2, '--m;');
        writeln(tab1, '}');
        writeln(tab1, 'while (N-- != 0)');
        writeln(tab2, '*S1++ = 0;');
        writeln('}')
        end;
    if usecase then
        begin
        writeln;
        writeln(static, voidtyp);
        writeln('Caseerror(n)');
        writeln(tab1, inttyp, tab1, 'n;');
        writeln('{');
        writeln(tab1, voidcast,
            'fprintf(stderr, "Missing case limb: line %d\n", n);');
        writeln(tab1, 'exit(1);');
        writeln('}')
        end;
    if usemax then
        begin
        writeln;
        writeln(static, inttyp);
        writeln('Max(m, n)');
        writeln(tab1, inttyp, tab1, 'm, n;');
        writeln('{');
        writeln(tab1, 'if (m > n)');
        writeln(tab2, 'return (m);');
        writeln(tab1, 'return (n);');
        writeln('}')
        end;
    if use(dtrunc) then
        begin
        writeln(static, inttyp);
        writeln('Trunc(f)');
        printid(defnams[dreal]^.lid);
        writeln(tab1, 'f;');
        writeln('{');
        writeln(tab1, 'return f;');
        writeln('}')
        end;
    if use(dround) then
        begin
        writeln(static, inttyp);
        writeln('Round(f)');
        printid(defnams[dreal]^.lid);
        writeln(tab1, 'f;');
        writeln('{');
        writeln(tab1, xtern, doubletyp, ' floor();');    (* LIB *)
        writeln(tab1,
            'return floor(', dblcast, '(0.5+f));');    (* LIB *)
        writeln('}')
        end
end;    (* emit *)

(*    Initialize all global structures used in translator.        *)
procedure initialize;

var    s    : hashtyp;
    t    : pretyps;
    d    : predefs;

    (*    Define names in ctable.                    *)
    procedure defname(cn : cnames; str : keyword);

    label    999;

    var    w    : toknbuf;
        i    : toknidx;

    begin
        unpack(str, w, 1);
        for i := 1 to keywordlen do
            if w[i] = space then
                begin
                w[i] := chr(null);
                goto 999
                end;
        w[keywordlen+1] := chr(null);
    999:
        ctable[cn] := saveid(w)
    end;

    (*    Define predefined identifiers.                *)
    procedure defid(nt : treetyp; did : predefs; str : keyword);

    label    999;

    var    w    : toknbuf;
        i    : toknidx;
        tp, tq,
        tv    : treeptr;

    begin
        for i := 1 to keywordlen do
            if str[i] = space then
                begin
                w[i] := chr(null);
                goto 999
                end
            else
                w[i] := str[i];
        w[keywordlen+1] := chr(null);
    999:
        tp := newid(saveid(w));
        defnams[did] := tp^.tsym;
        if nt in [ntype, nfunc, nproc] then
            begin
            (* predefined types, procedures and functions
                are marked with a particular node *)
            tv := mknode(npredef);
            tv^.tdef := did;
            tv^.tobtyp := tnone
            end
        else
            tv := nil; (* predefined constants and variables will
                    eventually be bound to something *)
        case nt of
          nscalar:
            begin
            tv := mknode(nscalar);
            tv^.tscalid := nil;
            tq := mknode(ntype);
            tq^.tbind := tv;
            tq^.tidl := tp;
            tp := tq
            end;
          nconst,
          ntype,
          nfield,
          nvar:
            begin
            tq := mknode(nt);
            tq^.tbind := tv;
            tq^.tidl := tp;
            tq^.tattr := anone;
            tp := tq
            end;
          nfunc,
          nproc:
            begin
            tq := mknode(nt);
            tq^.tsubid := tp;
            tq^.tsubstmt := tv;
            tq^.tfuntyp := nil;
            tq^.tsubpar := nil;
            tq^.tsublab := nil;
            tq^.tsubconst := nil;
            tq^.tsubtype := nil;
            tq^.tsubvar := nil;
            tq^.tsubsub := nil;
            tq^.tscope := nil;
            tq^.tstat := 0;
            tp := tq
            end;
          nid:
        end;(* case *)
        deftab[did] := tp
    end;    (* defid *)

    (*    Define keywords.                    *)
    procedure defkey(s : symtyp; w : keyword);

    var    i    : 1 .. keywordlen;

    begin
        for i := 1 to keywordlen do
            if w[i] = space then
                w[i] := chr(null);
        (* relies on symtyp being sorted *)
        with keytab[ord(s)] do
            begin
            wrd := w;
            sym := s
            end;
    end;

    procedure fixinit(i : strindx);

    var    t    : toknbuf;

    begin
        gettokn(i, t);
        t[1] := 'i';
        puttokn(i, t);
    end;

    (*    Add a cpu word type description.            *)
    (*    Parameters lo and hi gives the range of a machine-    *)
    (*    dependant integer type. Parameter str gives the corres-    *)
    (*    ponding C-language type-name.                *)
    procedure defmach(lo, hi : integer; str : machdefstr);

    label    999;

    var    i    : toknidx;
        w    : toknbuf;

    begin
        unpack(str, w, 1);
        if w[machdeflen] <> space then
            error(ebadmach);
        for i := machdeflen - 1 downto 1 do
            if w[i] <> space then
                begin
                w[i+1] := chr(null);
                goto 999
                end;
        error(ebadmach);
    999:
        if nmachdefs >= maxmachdefs then
            error(emanymachs);
        nmachdefs := nmachdefs + 1;
        with machdefs[nmachdefs] do
            begin
            lolim := lo;
            hilim := hi;
            typstr := savestr(w)
            end
    end;

    procedure initstrstore;

    var    i    : strbcnt;

    begin
        for i := 1 to maxblkcnt do
            strstor[i] := nil;
        new(strstor[0]);
        strstor[0]^[0] := chr(null);
        strfree := 1;
        strleft := maxstrblk
    end;

begin    (* initialize *)
    lineno := 1;
    colno := 0;

    initstrstore;

    setlst := nil;
    setcnt := 0;
    hexdig := '0123456789ABCDEF';

    symtab := nil;
    statlvl := 0;
    maxlevel := -1;
    enterscope(nil);
    varno:= 0;

    usenilp := false;

    usesets := false;
    useunion := false;
    usediff := false;
    usemksub := false;
    useintr := false;
    usesge := false;
    usesle := false;
    usesne := false;
    useseq := false;
    usememb := false;
    useins := false;
    usescpy := false;
    usefopn := false;
    usescan := false;
    usegetl := false;

    usecase := false;
    usejmps := false;

    usebool := false;

    usecomp := false;
    usemax    := false;

    for s := 0 to hashmax do
        idtab[s] := nil;
    for d := dabs to dztring do
        begin
        deftab[d] := nil;
        defnams[d] := nil
        end;

    (* Pascal keywords *)
    defkey(sand,    'and       ');
    defkey(sarray,    'array     ');
    defkey(sbegin,    'begin     ');
    defkey(scase,    'case      ');
    defkey(sconst,    'const     ');
    defkey(sdiv,    'div       ');
    defkey(sdo,    'do        ');
    defkey(sdownto,    'downto    ');
    defkey(selse,    'else      ');
    defkey(send,    'end       ');
    defkey(sextern,    externsym);    (* non-standard *)
    defkey(sfile,    'file      ');
    defkey(sfor,    'for       ');
    defkey(sforward,'forward   ');
    defkey(sfunc,    'function  ');
    defkey(sgoto,    'goto      ');
    defkey(sif,    'if        ');
    defkey(sinn,    'in        ');
    defkey(slabel,    'label     ');
    defkey(smod,    'mod       ');
    defkey(snil,    'nil       ');
    defkey(snot,    'not       ');
    defkey(sof,    'of        ');
    defkey(sor,    'or        ');
    defkey(sother,    othersym);    (* non-standard *)
    defkey(spacked,    'packed    ');
    defkey(sproc,    'procedure ');
    defkey(spgm,    'program   ');
    defkey(srecord,    'record    ');
    defkey(srepeat,    'repeat    ');
    defkey(sset,    'set       ');
    defkey(sthen,    'then      ');
    defkey(sto,    'to        ');
    defkey(stype,    'type      ');
    defkey(suntil,    'until     ');
    defkey(svar,    'var       ');
    defkey(swhile,    'while     ');
    defkey(swith,    'with      ');
    defkey(seof,    dummysym);    (* dummy entry *)

    (* C language operator priorities *)
    cprio[nformat]    := 0;
    cprio[nrange]    := 0;
    cprio[nin]    := 0;
    cprio[nset]    := 0;
    cprio[nassign]    := 0;
    cprio[nor]    := 1;
    cprio[nand]    := 2;
    cprio[neq]    := 3;
    cprio[nne]    := 3;
    cprio[nlt]    := 3;
    cprio[nle]    := 3;
    cprio[ngt]    := 3;
    cprio[nge]    := 3;
    cprio[nplus]    := 4;
    cprio[nminus]    := 4;
    cprio[nmul]    := 5;
    cprio[ndiv]    := 5;
    cprio[nmod]    := 5;
    cprio[nquot]    := 5;
    cprio[nnot]    := 6;
    cprio[numinus]    := 6;
    cprio[nuplus]    := 7;
    cprio[nindex]    := 7;
    cprio[nselect]    := 7;
    cprio[nderef]    := 7;
    cprio[ncall]    := 7;
    cprio[nid]    := 7;
    cprio[nchar]    := 7;
    cprio[ninteger]    := 7;
    cprio[nreal]    := 7;
    cprio[nstring]    := 7;
    cprio[nnil]    := 7;

    (* Pascal language operator priorities *)
    pprio[nassign]    := 0;
    pprio[nformat]    := 0;
    pprio[nrange]    := 1;
    pprio[nin]    := 1;
    pprio[neq]    := 1;
    pprio[nne]    := 1;
    pprio[nlt]    := 1;
    pprio[nle]    := 1;
    pprio[ngt]    := 1;
    pprio[nge]    := 1;
    pprio[nor]    := 2;
    pprio[nplus]    := 2;
    pprio[nminus]    := 2;
    pprio[nand]    := 3;
    pprio[nmul]    := 3;
    pprio[ndiv]    := 3;
    pprio[nmod]    := 3;
    pprio[nquot]    := 3;
    pprio[nnot]    := 4;
    pprio[numinus]    := 4;
    pprio[nuplus]    := 5;
    pprio[nset]    := 6;
    pprio[nindex]    := 6;
    pprio[nselect]    := 6;
    pprio[nderef]    := 6;
    pprio[ncall]    := 6;
    pprio[nid]    := 6;
    pprio[nchar]    := 6;
    pprio[ninteger]    := 6;
    pprio[nreal]    := 6;
    pprio[nstring]    := 6;
    pprio[nnil]    := 6;

    (* table of C keywords/functions (which Pascal doesn't know about) *)
    defname(cabort,        'abort     ');    (* OS *)
    defname(cbreak,        'break     ');
    defname(ccontinue,    'continue  ');
    defname(cdefine,    'define    ');
    defname(cdefault,    'default   ');
    defname(cdouble,    'double    ');
    defname(cedata,        'edata     ');    (* OS *)
    defname(cenum,        'enum      ');
    defname(cetext,        'etext     ');    (* OS *)
    defname(cextern,    'extern    ');
    defname(cfclose,    'fclose    ');    (* LIB *)
    defname(cfflush,    'fflush    ');    (* LIB *)
    defname(cfgetc,        'fgetc     ');    (* LIB *)
    defname(cfloat,        'float     ');
    defname(cfloor,        'floor     ');    (* OS *)
    defname(cfprintf,    'fprintf   ');    (* LIB *)
    defname(cfputc,        'fputc     ');    (* LIB *)
    defname(cfread,        'fread     ');    (* LIB *)
    defname(cfscanf,    'fscanf    ');    (* LIB *)
    defname(cfwrite,    'fwrite    ');    (* LIB *)
    defname(cgetc,        'getc      ');    (* OS *)
    defname(cgetpid,    'getpid    ');    (* OS *)
    defname(cint,        'int       ');
    defname(cinclude,    'include   ');
    defname(clong,        'long      ');
    defname(clog,        'log       ');    (* OS *)
    defname(cmain,        'main      ');
    defname(cmalloc,    'malloc    ');    (* LIB *)
    defname(cprintf,    'printf    ');    (* LIB *)
    defname(cpower,        'pow       ');    (* OS *)
    defname(cputc,        'putc      ');    (* LIB *)
    defname(cread,        'read      ');    (* OS *)
    defname(creturn,    'return    ');
    defname(cregister,    'register  ');
    defname(crewind,    'rewind    ');    (* LIB *)
    defname(cscanf,        'scanf     ');    (* LIB *)
    defname(csetbits,    'setbits   ');
    defname(csetword,    'setword   ');
    defname(csetptr,    'setptr    ');
    defname(cshort,        'short     ');
    defname(csigned,    'signed    ');
    defname(csizeof,    'sizeof    ');
    defname(csprintf,    'sprintf   ');    (* LIB *)
    defname(cstatic,    'static    ');
    defname(cstdin,        'stdin     ');    (* LIB *)
    defname(cstdout,    'stdout    ');    (* LIB *)
    defname(cstderr,    'stderr    ');    (* LIB *)
    defname(cstrncmp,    'strncmp   ');    (* OS *)
    defname(cstrncpy,    'strncpy   ');    (* OS *)
    defname(cstruct,    'struct    ');
    defname(cswitch,    'switch    ');
    defname(ctypedef,    'typedef   ');
    defname(cundef,        'undef     ');
    defname(cungetc,    'ungetc    ');    (* LIB *)
    defname(cunion,        'union     ');
    defname(cunlink,    'unlink    ');    (* OS *)
    defname(cunsigned,    'unsigned  ');
    defname(cwrite,        'write     ');    (* OS *)

    (* create predefined identifiers *)
    defid(nfunc,    dabs,        'abs       ');
    defid(nfunc,    darctan,    'arctan    ');
    defid(nvar,    dargc,        'argc      ');    (* OS *)
    defid(nproc,    dargv,        'argv      ');    (* OS *)
    defid(nscalar,    dboolean,    'boolean   ');
    defid(ntype,    dchar,        'char      ');
    defid(nfunc,    dchr,        'chr       ');
    defid(nproc,    dclose,        'close     ');    (* OS *)
    defid(nfunc,    dcos,        'cos       ');
    defid(nproc,    ddispose,    'dispose   ');
    defid(nid,    dfalse,        'false     ');
    defid(nfunc,    deof,        'eof       ');
    defid(nfunc,    deoln,        'eoln      ');
    defid(nproc,    dexit,        'exit      ');    (* OS *)
    defid(nfunc,    dexp,        'exp       ');
    defid(nproc,    dflush,        'flush     ');    (* OS *)
    defid(nproc,    dget,        'get       ');
    defid(nproc,    dhalt,        'halt      ');    (* OS *)
    defid(nvar,    dinput,        'input     ');
    defid(ntype,    dinteger,    'integer   ');
    defid(nfunc,    dln,        'ln        ');
    defid(nconst,    dmaxint,    'maxint    ');
    defid(nproc,    dmessage,    'message   ');    (* OS *)
    defid(nproc,    dnew,        'new       ');
    defid(nfunc,    dodd,        'odd       ');
    defid(nfunc,    dord,        'ord       ');
    defid(nvar,    doutput,    'output    ');
    defid(nproc,    dpack,        'pack      ');
    defid(nproc,    dpage,        'page      ');
    defid(nfunc,    dpred,        'pred      ');
    defid(nproc,    dput,        'put       ');
    defid(nproc,    dread,        'read      ');
    defid(nproc,    dreadln,    'readln    ');
    defid(ntype,    dreal,        'real      ');
    defid(nproc,    dreset,        'reset     ');
    defid(nproc,    drewrite,    'rewrite   ');
    defid(nfunc,    dround,        'round     ');
    defid(nfunc,    dsin,        'sin       ');
    defid(nfunc,    dsqr,        'sqr       ');
    defid(nfunc,    dsqrt,        'sqrt      ');
    defid(nfunc,    dsucc,        'succ      ');
    defid(ntype,    dtext,        'text      ');
    defid(nid,    dtrue,        'true      ');
    defid(nfunc,    dtrunc,        'trunc     ');
    defid(nfunc,    dtan,        'tan       ');
    defid(nproc,    dunpack,    'unpack    ');
    defid(nproc,    dwrite,        'write     ');
    defid(nproc,    dwriteln,    'writeln   ');

    defid(nfield,    dzinit,        '$nit      ');    (* for internal use *)
    defid(ntype,    dztring,    '$ztring   ');

    (* bind constants and variables *)
    deftab[dboolean]^.tbind^.tscalid := deftab[dfalse];
    deftab[dfalse]^.tnext := deftab[dtrue];
    currsym.st := sinteger;
    currsym.vint := maxint;
    deftab[dmaxint]^.tbind := mklit;
    deftab[dargc]^.tbind := deftab[dinteger]^.tbind;
    deftab[dinput]^.tbind := deftab[dtext]^.tbind;
    deftab[doutput]^.tbind := deftab[dtext]^.tbind;

    for t := tnone to terror do
        begin
        (* for predefined types: set up pointers to "npredef" nodes
           describing type, fill in constant identifying type *)
        case t of
          tboolean:
            typnods[t] := deftab[dboolean]; (* scalar type *)
          tchar:
            typnods[t] := deftab[dchar]^.tbind;
          tinteger:
            typnods[t] := deftab[dinteger]^.tbind;
          treal:
            typnods[t] := deftab[dreal]^.tbind;
          ttext:
            typnods[t] := deftab[dtext]^.tbind;
          tstring:
            typnods[t] := deftab[dztring]^.tbind;
          tnil,
          tset,
          tpoly,
          tnone:
            typnods[t] := mknode(npredef);
          terror:
            (* no op *)
        end;(* case *)
        if t in [tchar, tinteger, treal, ttext, tnone, tpoly,
                        tstring, tnil, tset] then
            typnods[t]^.tobtyp := t
        end;

    (* fix name and type of field "init" *)
    fixinit(defnams[dzinit]^.lid^.istr);
    deftab[dzinit]^.tbind := deftab[dinteger]^.tbind;

    for d := dabs to dztring do
        linkup(nil, deftab[d]);

    deftab[dchr]^.tfuntyp := typnods[tchar];

    deftab[deof]^.tfuntyp := typnods[tboolean];
    deftab[deoln]^.tfuntyp := typnods[tboolean];
    deftab[dodd]^.tfuntyp := typnods[tboolean];

    deftab[dord]^.tfuntyp := typnods[tinteger];
    deftab[dround]^.tfuntyp := typnods[tinteger];
    deftab[dtrunc]^.tfuntyp := typnods[tinteger];

    deftab[darctan]^.tfuntyp := typnods[treal];
    deftab[dcos]^.tfuntyp := typnods[treal];
    deftab[dsin]^.tfuntyp := typnods[treal];
    deftab[dtan]^.tfuntyp := typnods[treal];
    deftab[dsqrt]^.tfuntyp := typnods[treal];
    deftab[dexp]^.tfuntyp := typnods[treal];
    deftab[dln]^.tfuntyp := typnods[treal];

    deftab[dsqr]^.tfuntyp := typnods[tpoly];
    deftab[dabs]^.tfuntyp := typnods[tpoly];
    deftab[dpred]^.tfuntyp := typnods[tpoly];
    deftab[dsucc]^.tfuntyp := typnods[tpoly];

    deftab[dargv]^.tfuntyp := typnods[tnone];
    deftab[ddispose]^.tfuntyp := typnods[tnone];
    deftab[dexit]^.tfuntyp := typnods[tnone];
    deftab[dget]^.tfuntyp := typnods[tnone];
    deftab[dhalt]^.tfuntyp := typnods[tnone];
    deftab[dnew]^.tfuntyp := typnods[tnone];
    deftab[dpack]^.tfuntyp := typnods[tnone];
    deftab[dput]^.tfuntyp := typnods[tnone];
    deftab[dread]^.tfuntyp := typnods[tnone];
    deftab[dreadln]^.tfuntyp := typnods[tnone];
    deftab[dreset]^.tfuntyp := typnods[tnone];
    deftab[drewrite]^.tfuntyp := typnods[tnone];
    deftab[dwrite]^.tfuntyp := typnods[tnone];
    deftab[dwriteln]^.tfuntyp := typnods[tnone];
    deftab[dmessage]^.tfuntyp := typnods[tnone];
    deftab[dunpack]^.tfuntyp := typnods[tnone];

    (* set up definitions for integer subranges *)
    nmachdefs := 0;
    defmach(0,        255,        'unsigned char   '); (* CPU *)
    defmach(-128,        127,        'char            '); (* CPU *)
    defmach(0,        65535,        'unsigned short  '); (* CPU *)
    defmach(-32768,        32767,        'short           '); (* CPU *)
    defmach(-2147483647,    2147483647,    'long            '); (* CPU *)
{    defmach(0,        4294967295,    'unsigned long   ');}(* CPU *)
end;    (* initialize *)

procedure exit(i : integer); external;    (* OS *)

(*    Action to take when an error is detected.            *)
procedure error;

begin
    prtmsg(m);
    exit(1);    (* OS *)
    goto 9999
end;

(*    Action to take when a fatal error is detected.            *)
procedure fatal;

begin
    prtmsg(m);
    halt        (* OS *)
    (* goto 9999    *)
end;


begin    (* program *)
    initialize;
    if echo then
        writeln('# ifdef PASCAL');
    parse;
    if echo then
        writeln('# else');
    lineno := 0; lastline := 0;
    transform;
    emit;
    if echo then
        writeln('# endif');
9999:
    (* the very *)
end.